home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 551-575 / disk_556 / scheme2c / scheme-src.lzh / scrt / screp.sc < prev    next >
Text File  |  1991-10-11  |  9KB  |  244 lines
  1. ;;; This file implements the basic "read-eval-print" for SCHEME->C.  The
  2. ;;; interpreter is designed so that it can be run either "stand-alone", or
  3. ;;; embedded in some application.  Initialization of this module will assure
  4. ;;; that the entire library is initialized.
  5.  
  6. ;*              Copyright 1989 Digital Equipment Corporation
  7. ;*                         All Rights Reserved
  8. ;*
  9. ;* Permission to use, copy, and modify this software and its documentation is
  10. ;* hereby granted only under the following terms and conditions.  Both the
  11. ;* above copyright notice and this permission notice must appear in all copies
  12. ;* of the software, derivative works or modified versions, and any portions
  13. ;* thereof, and both notices must appear in supporting documentation.
  14. ;*
  15. ;* Users of this software agree to the terms and conditions set forth herein,
  16. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  17. ;* right and license under any changes, enhancements or extensions made to the
  18. ;* core functions of the software, including but not limited to those affording
  19. ;* compatibility with other hardware or software environments, but excluding
  20. ;* applications which incorporate this software.  Users further agree to use
  21. ;* their best efforts to return to Digital any such changes, enhancements or
  22. ;* extensions that they make and inform Digital of noteworthy uses of this
  23. ;* software.  Correspondence should be provided to Digital at:
  24. ;* 
  25. ;*                       Director of Licensing
  26. ;*                       Western Research Laboratory
  27. ;*                       Digital Equipment Corporation
  28. ;*                       100 Hamilton Avenue
  29. ;*                       Palo Alto, California  94301  
  30. ;* 
  31. ;* This software may be distributed (but not offered for sale or transferred
  32. ;* for compensation) to third parties, provided such third parties agree to
  33. ;* abide by the terms and conditions of this notice.  
  34. ;* 
  35. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  36. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  37. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  38. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  39. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  40. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  41. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  42. ;* SOFTWARE.
  43.  
  44. (module screp
  45.     (top-level TOP-LEVEL READ-EVAL-PRINT LOAD LOADE LOADQ)
  46.     (with scdebug sceval scexpand scexpanders1 scexpanders2 scqquote))
  47.  
  48. ;;; External definitions.
  49.  
  50. (define-constant SIG_IGN 1)
  51. (define-constant SIGINT  2)
  52. (define-constant SIGFPE  8)
  53. (define-constant SIGBUS  10)
  54. (define-constant SIGSEGV 11)
  55. (define-constant SIGSYS  12)
  56.  
  57. (define-external CURRENT-INPUT-PORT-VALUE scrt5)
  58.  
  59. (define-external CURRENT-OUTPUT-PORT-VALUE scrt5)
  60.  
  61. (define-external OPEN-FILE-PORTS scrt5)
  62.  
  63. (include "repdef.sc")
  64.  
  65. ;;; The function TOP-LEVEL will return to the outer most interpreter.
  66.  
  67. (define  TOP-LEVEL #f)
  68.  
  69. ;;; The global flag *EMACSCHEME* indicates whether interpreter is running
  70. ;;; in GNU emacs.
  71.  
  72. (define  *EMACSCHEME* #f)
  73.  
  74. ;;; The global flag *READING-STDIN* indicates that the interpreter is reading
  75. ;;; stdin.  If control-c is pressed while this is true, then the debugger
  76. ;;; is not entered and a reset is performed.
  77.  
  78. (define *READING-STDIN* #f)
  79.  
  80. ;;; The entry point to this module is the following function.  On entry it
  81. ;;; saves the current EXIT, RESET, TRACE-LEVEL, and keyboard interrupt
  82. ;;; handler.  After arming the keyboard interrupt, it passes control
  83. ;;; to the next step, REP.  On return from that function, the saved values
  84. ;;; will be restored and then the function will exit.
  85. ;;;
  86. ;;; The function is called with an optional list of options.  They are:
  87. ;;;
  88. ;;;    ECHO    -        echo the input on the output file.
  89. ;;;    "-e"
  90. ;;;    QUIET    -        do not print the result on the output file.
  91. ;;;    "-q"
  92. ;;;    PROMPT  "prompt" / #f    prompt input with the string "prompt".
  93. ;;;    "-np"            do not prompt input.
  94. ;;;    HEADER    "header" / #f    print the "header" on entry.
  95. ;;;    "-nh"            do not print header.
  96. ;;;    LOAD            LOAD / LOADE / LOADQ from current input.
  97. ;;;     RESULT  value        value to return unless overridden by proceed.
  98. ;;;    ENV    alist        interpreter environment.
  99. ;;;     "-emacs"        GNU emacs mode 
  100.  
  101. (define (READ-EVAL-PRINT . flags)
  102.     (letrec ((save-exit exit)
  103.          (save-reset reset)
  104.          (save-interrupt (signal sigint sig_ign))
  105.          (save-trace trace-level)
  106.          (input current-input-port-value)
  107.          (output current-output-port-value)
  108.          (echoinput (or (member 'echo flags) (member "-e" flags)))
  109.          (quiet (or (member 'quiet flags) (member "-q" flags)))
  110.          (prompt (let ((x (member 'prompt flags)))
  111.               (cond (x (cadr x))
  112.                 ((member "-np" flags) #f)
  113.                 (else "> "))))
  114.          (header (let ((x (member 'header flags)))
  115.               (cond (x (cadr x))
  116.                 ((member "-nh" flags) #f)
  117.                 (else (format "~a -- ~a -- ~a ~a"
  118.                         (car (implementation-information))
  119.                         (cadr (implementation-information))
  120.                                 "Copyright 1989 Digital"
  121.                         "Equipment Corporation")))))
  122.          (env (let ((x (member 'env flags)))
  123.                (if x (cadr x) '())))
  124.          (load (member 'load flags))
  125.          (return-value (let ((x (member 'result flags)))
  126.                 (if x (cadr x) #f)))
  127.          
  128.          ;;; Exit function and proceed functions.
  129.          (MAKE-EXIT
  130.          (lambda (exit-here)
  131.              (set! proceed
  132.                    (lambda x (if x (set! return-value (car x)))
  133.                      (exit-here #f)))
  134.              (set! exit (lambda () (exit-here #f)))
  135.              #t))
  136.          
  137.          ;;; Reset function.
  138.          (MAKE-RESET
  139.          (lambda (reset-here)
  140.              (if (not load)
  141.                  (set! reset
  142.                    (let ((save-exit exit))
  143.                      (lambda ()
  144.                          (set! exit save-exit)
  145.                          (reset-here #f)))))
  146.              #t))
  147.  
  148.          ;;; One-time initialization code to set up TOP-LEVEL, backtracing
  149.          ;;; error handler, and trap handlers.
  150.          (ONE-TIME-INITIALIZATION
  151.          (lambda ()
  152.                  (set! *emacscheme* (member "-emacs" flags))
  153.              (set! top-level
  154.                    (let ((top-reset reset))
  155.                     (lambda ()
  156.                         (set! *debug-on-error* #t)
  157.                         (set! reset top-reset)
  158.                         (reset))))
  159.              (set! *error-handler* backtrace-error-handler)
  160.              (set! *debug-on-error* #t)
  161.              (signal sigbus
  162.                  (lambda (sig) (error '???? "Bus error")))
  163.              (signal sigsegv
  164.                  (lambda (sig) (error '????
  165.                            "Segment violation")))
  166.              (signal sigsys
  167.                  (lambda (sig) (error '????
  168.                          "Bad argument to system call"
  169.                          ))))))
  170.  
  171.         ;;; Function body starts here.
  172.         (if (call-with-current-continuation make-exit)
  173.         (begin (if (call-with-current-continuation make-reset)
  174.                (begin (cond (load
  175.                         (signal sigint save-interrupt))
  176.                     ((not (eq? save-interrupt sig_ign))
  177.                      (signal sigint on-interrupt)))
  178.                   (if echoinput (echo input output))
  179.                    (if header
  180.                       (format stdout-port "~a~%" header)))
  181.                (begin (set! current-input-port-value input)
  182.                   (set! current-output-port-value output)
  183.                   (set! trace-level save-trace)))
  184.                (if (not top-level) (one-time-initialization))
  185.                (rep env (if load (current-input-port) stdin-port)
  186.                 stdout-port prompt quiet)))
  187.         (signal sigint save-interrupt)
  188.         (if echoinput (echo input #f))
  189.         (set! exit save-exit)
  190.         (set! reset save-reset)
  191.         (set! trace-level save-trace)
  192.         return-value))
  193.  
  194. ;;; Flushes white space characters from the input file.
  195.  
  196. (define (FLUSH-WHITE inport)
  197.     (let ((c (and (char-ready? inport) (peek-char inport))))
  198.      (if (and c (not (eof-object? c)) (char-whitespace? c))
  199.          (begin (read-char inport)
  200.             (flush-white inport)))))
  201.  
  202. ;;; REP is called from READ-EVAL-PRINT to actually read the commands once
  203. ;;; the initial environment is set up.
  204.  
  205. (define (REP env inport outport prompt quiet)
  206.     (let loop ((exp #f))
  207.      (flush-white inport)
  208.      (if (and prompt (not (char-ready? inport))) (display prompt outport))
  209.      (set! *reading-stdin* (eq? inport stdin-port))
  210.      (set! exp (read inport))
  211.      (set! *reading-stdin* #f)
  212.      (cond ((eof-object? exp)
  213.         (if prompt (newline outport)))
  214.            ((and (pair? exp) (memq (car exp) '(module include)))
  215.         (flush-white inport)
  216.         (if (not quiet)
  217.             (format outport "~s form ignored~%" (car exp)))
  218.         (loop #f))
  219.            (else (if *emacscheme* (newline outport))
  220.              (set! exp (eval exp env))
  221.              (flush-white inport)
  222.              (if (not quiet) (format outport "~s~%" exp))
  223.              (loop #f)))))
  224.  
  225. ;;; Expressions within files are loaded by the following functions.
  226.  
  227. (define (LOAD file-name)
  228.     (with-input-from-file
  229.     file-name
  230.     (lambda () (read-eval-print 'header #f 'prompt #f 'load)))
  231.     file-name)
  232.  
  233. (define (LOADQ file-name)
  234.     (with-input-from-file
  235.     file-name
  236.     (lambda () (read-eval-print 'header #f 'prompt #f 'quiet 'load)))
  237.     file-name)
  238.  
  239. (define (LOADE file-name)
  240.     (with-input-from-file
  241.     file-name
  242.     (lambda () (read-eval-print 'header #f 'prompt #f 'echo 'load)))
  243.     file-name)
  244.